perm filename CNTOUR[CRE,BGB] blob
sn#021801 filedate 1973-01-28 generic text, type T, neo UTF8
00100 SUBR(THRESH)------------------------------------------------------
00200 BEGIN THRESH;THRESHOLD(LEVEL) pre foonly version. BGB 4 DEC 1972.
00300 SKIPE FLGKRK↔DETSEG
00400 ;SOUBIT TO PAC FOR PIXELS ≥ CUT.
00500 I←13 ↔ J←14
00600 CALL(SEGTV)
00700 LAC [XWD L,2]↔BLT 13
00800 LAC ARG1↔LSH -3↔DAC HCUT
00900 LAP 5,ARG1
01000 GO 3
01100
01200 ;ACCUMULATOR LOOP.
01300 L: POINT 6,TVBUF,-1
01400 MOVEI J,=36 ;3
01500 ILDB 2 ;4
01600 SUBI ;CUT ;5
01700 ROTC 1 ;6
01800 SOJG J,4 ;7
01900 SETCAM 1,PAC(I) ;10
02000 AOBJN I,3 ;11
02100 POP1J ;12
02200 XWD -=1728,0 ;13
02300 BEND;12/17/72-----------------------------------------------------
02400
02500 HCUT: 0 ;HCUT GLOBAL FROM THRESH TO MKPGONS.
02600
02700 SUBR(PACXOR)------------------------------------------------------
02800 BEGIN PACXOR;do rook's exclusive OR'ing. BGB 4-DEC-72.
02900 I←2
03000 SLACI PAC↔LAPI HSEG↔BLT HSEG+=1727
03100 SLACI PAC↔LAPI VSEG↔BLT VSEG+=1727
03200 SETZ I,
03300 HRRI PAC↔DAP L+2
03400 L: TRNN I,7↔SETZ 1,↔LAC PAC(I)
03500 XORM HSEG+8(I) ; HSEG SOUBIT are above PAC bits.
03600 ROTC -1↔ROT 1,1
03700 XORM VSEG(I) ; VSEG are left of PAC bits.
03800 AOS I
03900 CAIE I,=1728
04000 GO L
04100 SETZM ISAVED
04200 POP0J
04300 BEND;12/4/72------------------------------------------------------
04400
00100 SUBR(HISTOG)---------------------------------------------------
00200 BEGIN HISTOG;MAKE HISTOGRAM OF TVBUF - BGB - 4 DEC 72.
00300
00400 CALL(SEGTV)
00500 SKIPE FTVHIS↔POP0J↔SETOM FTVHIS
00600 LAC[XWD HISTO,HISTO+1]↔SETZM HISTO↔BLT HISTO+77
00700 LAC 7,[XWD L,0]↔BLT 7,6↔GO 2
00800
00900 ;ACCUMULATOR LOOP.
01000 L: =62208 ;0
01100 0 ;1
01200 ILDB 1,6 ;2
01300 AOS HISTO(1) ;3
01400 SOJG 0,2 ;4
01500 POP0J ;5
01600 POINT 6,TVBUF,-1;6
01700
01800 BEND;12/16/72-----------------------------------------------------
01900
02000 SUBR(BIMOD)-------------------------------------------------------
02100 BEGIN BIMOD;BI-MODAL HISTOGRAM CUT HIGH AND CUT LOW - 14 DEC 72.
02200 ACCUMULATORS{Q1,Q2,HI,LO}
02300 CALL(HISTOG)
02400 LACI HI,77↔SETZM LO↔SETZB Q1,Q2
02500 SETZ↔SKIPE CTRL↔GO[INCHRW↔ANDI 17↔GO .+1]
02600 SKIPE META↔GO[INCHRW 1↔ANDI 1,17↔IMULI =10↔ADD 1↔GO .+1]
02700 SKIPN↔LACI 3↔IMULI =62208↔IDIVI =100↔DAC 1
02800
02900 ;COME IN FROM THE EXTREMES 3 PER CENT.
03000 SETZ↔ADD HISTO(LO)↔CAMGE 1↔AOJA LO,.-2
03100 SETZ↔ADD HISTO(HI)↔CAMGE 1↔SOJA HI,.-2
03200 L2: CAML LO,HI↔POP0J
03300 SKIPN FTVSIX↔GO L3
03400
03500 ;LOOK FOR LOCAL MINIMUM.
03600 LAC HISTO(LO)↔CAML HISTO+1(LO)↔AOJA LO,L2
03700 LAC HISTO(LO)↔CAML HISTO-1(LO)↔AOJA LO,L2
03800 LAC HISTO(HI)↔CAML HISTO+1(HI)↔SOJA HI,L2
03900 LAC HISTO(HI)↔CAML HISTO-1(HI)↔SOJA HI,L2
04000
04100 ;CUT 'EM UP AND DISPLAY 'EM.
04200 L3: MOVNS LO↔MOVNS HI
04300 SETZ Q2,↔SLACI Q1,1B18↔LSHC Q1,(LO)
04400 SETZB 0,1↔SLACI 1B18↔LSHC(HI)↔IOR Q1,0↔IOR Q2,1
04500 CALL(CRE,Q1,Q2)
04600 CALL(DPYIMG)
04700 POP0J
04800 BEND;12/14/72-----------------------------------------------------
00100 SUBR(MKPGON)LEVEL--------------------------------------------------
00200 BEGIN MKPGON;MAKE AN INTENSITY CONTOUR POLYGON - BGB - AUGUST 1972.
00300
00400 ACCUMULATORS{A2,A3,RC.,MASK,I,PTR,D,E,V,PG,BITQ,H1,H2}
00500 LAC H1,HCUT↔LACI H2,7↔SUB H2,H1
00600 LAC I,ISAVED↔CDR PTR,ARG1↔LACI BITQ,VREL
00700 SLACI I↔HRRI PAC↔DAC PACPTR#; PAC POINTER INDEXED BY I.
00800
00900 ;FIND THE ROW & COL OF THE UPPER LEFT MOST VSEG.
01000 L1: SKIPE 1,VSEG(I)↔GO L2
01100 AOS I↔CAIE I,=1728↔GO L1
01200 SETZ 1,↔POP1J;EMPTY.
01300
01400 L2: DAC I,ISAVED↔JFFO 1,.+1↔SLACI MASK,400000
01500 MOVNS 2↔LSH MASK,(2)↔MOVNS 2
01600 LAC RC.,I↔ANDI RC.,7↔IMULI RC.,=36↔ADD RC.,2 ;COLUMN.
01700 LAC I↔LSH -3↔DIP RC.↔LSH RC.,6 ;ROW.
01800
01900 ;DISTINGUISH BLOBS FROM HOLES.
02000 SETZM HOLE#
02100 TDNN MASK,@PACPTR ;HOLE OR BLOB ?
02200 SETOM HOLE# ;HOLE'A'COMING.
02300 SKIPE HOLE↔EXCH H1,H2
02400
02500 ;AND HEAD SOUTH.
02600
02700 SETQ(PG,{MAKE,[PBIT+PGNREL]})
02800 LAC 0,ARG1↔DAD. 0,PG↔CALL(RINGIN,PG,0)
02900 SKIPE HOLE↔GO[MARK PG,HOLBIT↔GO .+1]
03000 DAC RC.,RCMIN#
03100 SETZM RCMAX#
03200 SETZ V,↔SETZM ECNT#
03300 PUSHJ P,FOLLOW
03400 LAC V,V0
03500 CCW. V,E↔CW. E,V
03600
03700 ;MAKE & RETURN VIC POLYGON.
03800
03900 LAC 1,ECNT↔SKIPE HOLE#↔MOVNS 1
04000 NCNT. 1,PG
04100 LAC V0↔SON. 0,PG ;UPPER MOST LEFT.
04200 LAC V1↔ARC. 0,PG ;LOWER MOST RIGHT.
04300 LAC 1,PG
04400 L3: POP1J
00100 ;THE SUB-OPERATIONS OF MKPGON.
00200
00300 DEFINE TRY (SEG,YES) {
00400 LAC SEG(I)↔TDZN MASK↔GO .+3↔DAC SEG(I)↔GO YES}
00500 DEFINE LEFT {SUBI RC.,100↔ROT MASK,1↔CAIN MASK,1↔SOS I}
00600 DEFINE RIGHT {ADDI RC.,100↔ROT MASK,-1↔SKIPG MASK↔AOS I}
00700 DEFINE UP {SUB RC.,[1B11]↔SUBI I,8}
00800 DEFINE DOWN {ADD RC.,[1B11]↔ADDI I,8}
00900
01000 ;CREATE NEW EDGE AND VERTEX OF A VIC.
01100 TURN: 0
01200 AOS TURNS#
01300 ADD D,RC.
01400 AOS 2,ECNT
01500
01600 ;VERTEX
01700 CALL MAKE,BITQ
01800 PGON. PG,1
01900 SKIPN V↔GO[DAC 1,V0#↔DAC 1,V↔GO T2]
02000 DAC 1,V
02100 CCW. V,E↔CW. E,V
02200 T2: DAC D,RC(V)
02300 CAMLE D,RCMAX
02400 GO[DAC D,RCMAX↔DAC V,V1#↔GO .+1]
02500 DAC V,E
02600 GO @TURN
00100 ;THE ALCHEMIST OF MKPGON - converts bits of lead into lines of gold.
00200
00300 NORTH: ADD D,[1B11]↔LIPI BITQ,(NORBIT+VBIT)↔JSR TURN
00400 NORTH2: LEFT↔LAC D,DELPM(H1)↔ TRY HSEG,WEST
00500 RIGHT↔UP↔ TRY VSEG,NORTH2
00600 DOWN↔LAC D,DELPP(H2)↔ TRY HSEG,EAST↔FATAL(NORTH)
00700 NORTH3: LIPI BITQ,(NORBIT+VBIT)↔JSR TURN↔LEFT
00800 NORTH4: UP↔LAC D,DELPM(H1)↔ TRY HSEG,WEST↔GO NORTH4
00900
01000
01100 WEST: ADDI D,100↔LIPI BITQ,(WESBIT+VBIT)↔JSR TURN
01200 WEST2: CAMN RC.,RCMIN↔POPJ P,;TRY FOR E.O.VIC.
01300 FOLLOW: LAC D,DELPP(H1)↔ TRY VSEG,SOUTH
01400 LEFT↔ TRY HSEG,WEST2
01500 RIGHT↔UP↔LAC D,DELMP(H2)↔TRY VSEG,NORTH↔FATAL(WEST)
01600
01700
01800 SOUTH: LIPI BITQ,(SOUBIT+VBIT)↔JSR TURN
01900 SOUTH2: DOWN↔LAC D,DELMP(H1)
02000 CAR RC.↔CAIN =216B29↔GO EAST3
02100 TRY HSEG, EAST
02200 TRY VSEG,SOUTH2
02300 LEFT↔LAC D,DELMM(H2)↔ TRY HSEG,WEST↔ FATAL(SOUTH)
02400
02500
02600 EAST: LIPI BITQ,(EASBIT+VBIT)↔JSR TURN
02700 EAST2: RIGHT↔LAC D,DELMM(H1)
02800 CDR RC.↔CAIN =288B29↔GO NORTH3
02900 UP↔ TRY VSEG,NORTH
03000 DOWN↔ TRY HSEG,EAST2
03100 LAC D,DELPM(H2)↔ TRY VSEG,SOUTH↔FATAL(EAST)
03200 EAST3: LIPI BITQ,(EASBIT+VBIT)↔JSR TURN↔UP
03300 EAST4: RIGHT↔LAC D,DELMM(H1)
03400 CDR RC.↔CAIN =288B29↔GO[DOWN↔GO NORTH3]
03500 TRY VSEG,NORTH↔GO EAST4
03600
03700 ;DEKINKING OFF SETS.
03800 DELPP: FOR I←24,33{XWD I,I↔}
03900 DELPM: FOR I←24,33{XWD I,-I↔}
04000 DELMP: FOR I←24,33{XWD -I,I↔}
04100 DELMM: FOR I←24,33{XWD -I,-I↔}
04200
04300 BEND;12/14/72-----------------------------------------------------
00100 SUBR(VICONT)LEVEL-------------------------------------------------
00200 BEGIN VICONT; VECTOR INTENSITY CONTRAST - BGB - 14 DEC 1972.
00300 ACCUMULATORS{R1,C1,V1,R2,C2,V2,PG,QQNW,QQSE,CNT,PTR,SAVCNT}
00400 CALL(SEGTV)
00500 LAC 1,ARG1↔SON PG,1↔DAC PG,PG0# ;FIRST POLYGON.
00600 L1: SON V2,PG↔DAC V2,V0# ;FIRST VECTOR.
00700 LAC RC(V2)↔ADD[XWD 40,40]
00800 CAR R2,↔LSH R2,-6
00900 CDR C2,↔LSH C2,-6
01000
01100 L2: LAC V1,V2↔LAC R1,R2↔LAC C1,C2↔CCW V2,V2 ;NEXT VECTOR.
01200 LAC RC(V2)↔ADD[XWD 40,40]
01300 CAR R2,↔LSH R2,-6↔CDR C2,↔LSH C2,-6 ;GET ROW & COL.
01400 SETZB QQNW,QQSE
01500 TESTZ V1,WESBIT↔GO WEST
01600 TESTZ V1,SOUBIT↔GO SOUTH
01700 TESTZ V1,EASBIT↔GO EAST
01800 TESTZ V1,NORBIT↔GO NORTH↔HALT
01900 L3: CAME V2,V0↔GO L2
02000 CCW PG,PG↔CAME PG,PG0↔GO L1 ;NEXT POLYGON.
02100 POP1J
02200 ;-----------------------------------------------------------------
02300 WEST: LAC ROWPTR(R2)↔ADD COLPTR-1(C2)
02400 LAC CNT,C1↔SUB CNT,C2↔CALL(EW)
02500 SUB QQSE,QQNW
02600 NTIME. QQSE,V1↔PTIME. SAVCNT,V1
02700 IDIV QQSE,SAVCNT
02800 CNTRS. QQSE,V1↔GO L3
02900
03000 SOUTH: LAC ROWPTR(R1)↔ADD COLPTR-2(C1)
03100 LAC CNT,R2↔SUB CNT,R1↔CALL(NS)
03200 SUB QQSE,QQNW
03300 NTIME. QQSE,V1↔PTIME. SAVCNT,V1
03400 IDIV QQSE,SAVCNT
03500 CNTRS. QQSE,V1↔GO L3
03600
03700 EAST: LAC ROWPTR(R1)↔ADD COLPTR-1(C1)
03800 LAC CNT,C2↔SUB CNT,C1↔CALL(EW)
03900 SUB QQNW,QQSE
04000 NTIME. QQNW,V1↔PTIME. SAVCNT,V1
04100 IDIV QQNW,SAVCNT
04200 CNTRS. QQNW,V1↔GO L3
04300
04400 NORTH: LAC ROWPTR(R2)↔ADD COLPTR-2(C2)
04500 LAC CNT,R1↔SUB CNT,R2↔CALL(NS)
04600 SUB QQNW,QQSE
04700 NTIME. QQNW,V1↔PTIME. SAVCNT,V1
04800 IDIV QQNW,SAVCNT
04900 CNTRS. QQNW,V1↔GO L3
05000 DECLARE{PTRNW,PTRSE}
05100 ;-----------------------------------------------------------------
00100 ;EAST-WEST.
00200 EW: DAC CNT,SAVCNT
00300 TLZ 1↔DAC PTRSE
00400 SUBI=48↔DAC PTRNW
00500
00600 EWL: ILDB PTRNW↔ADDM QQNW
00700 ILDB PTRSE↔ADDM QQSE
00800 SOJG CNT,EWL
00900
01000 CAIG R1,0↔SETZ QQNW,
01100 CAIL R1,=216↔SETZ QQSE,
01200 POP0J
01300
01400 ;NORTH-SOUTH.
01500 NS: DAC CNT,SAVCNT↔TLZ 1↔DAC PTR↔TDCA 1,1
01600
01700 NSL: LACI 1,=48↔ADDB 1,PTR
01800 ILDB 1↔ADDM QQNW
01900 ILDB 1↔ADDM QQSE
02000 SOJG CNT,NSL
02100
02200 CAIG C1,0↔SETZ QQNW,
02300 CAIL C1,=288↔SETZ QQSE,
02400 POP0J
02500
02600 BEND;1/7/73-------------------------------------------------------